home *** CD-ROM | disk | FTP | other *** search
/ Mac-Source 1994 July / Mac-Source_July_1994.iso / Other Langs / Tickle-4.0 (tcl) / library / tcllib.tcl < prev    next >
Encoding:
Text File  |  1993-11-03  |  7.2 KB  |  217 lines  |  [TEXT/MPS ]
  1. #----------
  2. # This file has been modified for Macintosh Tcl and Tickle. -- Tim Endres
  3. #----------
  4.  
  5. #
  6. # tcllib.tcl --
  7. #
  8. # Various command dealing with auto-load libraries.  Some of this code is
  9. # taken directly from the UCB Tcl library:init.tcl file.
  10. #------------------------------------------------------------------------------
  11. # Copyright 1992-1993 Karl Lehenbauer and Mark Diekhans.
  12. #
  13. # Permission to use, copy, modify, and distribute this software and its
  14. # documentation for any purpose and without fee is hereby granted, provided
  15. # that the above copyright notice appear in all copies.  Karl Lehenbauer and
  16. # Mark Diekhans make no representations about the suitability of this
  17. # software for any purpose.  It is provided "as is" without express or
  18. # implied warranty.
  19. #------------------------------------------------------------------------------
  20. # Copyright (c) 1991-1993 The Regents of the University of California.
  21. # All rights reserved.
  22. #
  23. # Permission is hereby granted, without written agreement and without
  24. # license or royalty fees, to use, copy, modify, and distribute this
  25. # software and its documentation for any purpose, provided that the
  26. # above copyright notice and the following two paragraphs appear in
  27. # all copies of this software.
  28. #
  29. # IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
  30. # DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
  31. # OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
  32. # CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  33. #
  34. # THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
  35. # INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  36. # AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
  37. # ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
  38. # PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
  39. #------------------------------------------------------------------------------
  40. # $Id: tcllib.tcl,v 1.3 1993/06/25 02:15:10 markd Exp $
  41. #------------------------------------------------------------------------------
  42. #
  43.  
  44. #@package: TclX-libraries searchpath auto_load_file
  45.  
  46. #------------------------------------------------------------------------------
  47. # searchpath:
  48. # Search a path list for a file. (catch is for bad ~user)
  49. #
  50. proc searchpath {pathlist file} {
  51.     foreach dir $pathlist {
  52.         if {$dir == ""} {set dir .}
  53.         if {[catch {file exists $dir:$file} result] == 0 && $result}  {
  54.             return $dir:$file
  55.         }
  56.     }
  57.     return {}
  58. }
  59.  
  60. #------------------------------------------------------------------------------
  61. # auto_load_file:
  62. # Search auto_path for a file and source it.
  63. #
  64. proc auto_load_file {name} {
  65.     global auto_path errorCode
  66.     if {[string first : $name] >= 0} {
  67.         return  [uplevel 1 source $name]
  68.     }
  69.     set where [searchpath $auto_path $name]
  70.     if [lempty $where] {
  71.         error "couldn't find $name in any directory in auto_path"
  72.     }
  73.     uplevel 1 source $where
  74. }
  75.  
  76. #@package: TclX-lib-list auto_packages auto_commands
  77.  
  78. #------------------------------------------------------------------------------
  79. # auto_packages:
  80. # List all of the loadable packages.  If -files is specified, the file paths
  81. # of the packages is also returned.
  82.  
  83. proc auto_packages {{option {}}} {
  84.     global auto_pkg_index
  85.  
  86.     auto_load  ;# Make sure all indexes are loaded.
  87.     if ![info exists auto_pkg_index] {
  88.         return {}
  89.     }
  90.     
  91.     set packList [array names auto_pkg_index] 
  92.     if [lempty $option] {
  93.         return $packList
  94.     }
  95.  
  96.     if {$option != "-files"} {
  97.         error "Unknow option \"$option\", expected \"-files\""
  98.     }
  99.     set locList {}
  100.     foreach pack $packList {
  101.         lappend locList [list $pack [lindex $auto_pkg_index($pack) 0]]
  102.     }
  103.     return $locList
  104. }
  105.  
  106. #------------------------------------------------------------------------------
  107. # auto_commands:
  108. # List all of the loadable commands.  If -loaders is specified, the commands
  109. # that will be involked to load the commands is also returned.
  110.  
  111. proc auto_commands {{option {}}} {
  112.     global auto_index
  113.  
  114.     auto_load  ;# Make sure all indexes are loaded.
  115.     if ![info exists auto_index] {
  116.         return {}
  117.     }
  118.     
  119.     set cmdList [array names auto_index] 
  120.     if [lempty $option] {
  121.         return $cmdList
  122.     }
  123.  
  124.     if {$option != "-loaders"} {
  125.         error "Unknow option \"$option\", expected \"-loaders\""
  126.     }
  127.     set loadList {}
  128.     foreach cmd $cmdList {
  129.         lappend loadList [list $cmd $auto_index($cmd)]
  130.     }
  131.     return $loadList
  132. }
  133.  
  134. #@package: TclX-ucblib auto_load_ouster_index auto_reset auto_mkindex
  135.  
  136. #------------------------------------------------------------------------------
  137. # auto_load_ouster_index:
  138. # Loads a Ousterhout-style index.  This sets up the local variables that
  139. # are expected by the index (which is really a script).
  140. #
  141. proc auto_load_ouster_index tclIndex {
  142.     global auto_index auto_path
  143.     set dir [file dirname $tclIndex]
  144.     source $tclIndex
  145. }
  146.  
  147. #------------------------------------------------------------------------------
  148. # auto_reset:
  149. # Destroy all cached information for auto-loading and auto-execution,
  150. # so that the information gets recomputed the next time it's needed.
  151. # Also delete any procedures that are listed in the auto-load index
  152. # except those related to auto-loading.
  153. # *** MODIFIED FOR TclX ***
  154.  
  155. proc auto_reset {} {
  156.     global auto_execs auto_index auto_oldpath
  157.     foreach p [info procs] {
  158.     if {[info exists auto_index($p)] && ($p != "unknown")
  159.         && ![string match auto_* $p]} {
  160.         rename $p {}
  161.     }
  162.     }
  163.     catch {unset auto_execs}
  164.     catch {unset auto_index}
  165.     catch {unset auto_oldpath}
  166.     # *** TclX ***
  167.     catch {unset auto_pkg_index}
  168.     set auto_index(buildpackageindex) {source [info library]:buildidx.tcl}
  169.     return
  170. }
  171.  
  172. #------------------------------------------------------------------------------
  173. # auto_mkindex:
  174. # Regenerate a tclIndex file from Tcl source files.  Takes two arguments:
  175. # the name of the directory in which the tclIndex file is to be placed,
  176. # and a glob pattern to use in that directory to locate all of the relevant
  177. # files.
  178.  
  179. proc auto_mkindex {dir files} {
  180.     global errorCode errorInfo
  181.     set oldDir [pwd]
  182.     cd $dir
  183.     set dir [pwd]
  184.     append index "# Tcl autoload index file, version 2.0\n"
  185.     append index "# This file is generated by the \"auto_mkindex\" command\n"
  186.     append index "# and sourced to set up indexing information for one or\n"
  187.     append index "# more commands.  Typically each line is a command that\n"
  188.     append index "# sets an element in the auto_index array, where the\n"
  189.     append index "# element name is the name of a command and the value is\n"
  190.     append index "# a script that loads the command.\n\n"
  191.     foreach file [glob $files] {
  192.     set f ""
  193.     set error [catch {
  194.         set f [open $file]
  195.         while {[gets $f line] >= 0} {
  196.         if [regexp {^proc[     ]+([^     ]*)} $line match procName] {
  197.             append index "set [list auto_index($procName)]"
  198.             append index " \"source \$dir:$file\"\n"
  199.         }
  200.         }
  201.         close $f
  202.     } msg]
  203.     if $error {
  204.         set code $errorCode
  205.         set info $errorInfo
  206.         catch [close $f]
  207.         cd $oldDir
  208.         error $msg $info $code
  209.     }
  210.     }
  211.     set f [open tclIndex w]
  212.     puts $f $index nonewline
  213.     close $f
  214.     cd $oldDir
  215. }
  216.  
  217.